					; la machine virtuelle
					;
					; Le code est DESCENDANT : on decremente le CO
					;
					; La pile est MONTANTE : on incremente le SP (pour push)
					;
					; CONVENTIONS : le CO pointe sur l'adresse de la prochaine instruction a executer
					; on doit donc effectuer l'instr a l'adr du CO avant de le decrementer
					;
					; le SP pointe sur le dernier emplacement utilisé de la pile
					; on doit donc incrementer le SP avant de push qqch sur la pile
					;
					; Le FP pointe initialement sur la case mem 1,
					; le but etant qu'il pointe sur la case qui contient le nombre de parametres
					; et que ces params soient en dessous de lui dans la pile

					; pour les SAUTS ,on saute a l'adresse +1 car on sait que le systeme va decrementer le CO ensuite
					;
					; Le CO est initialisé à MAXMEM

					; admet un entier en adr et n'importe quelle valeur
(defun ecrire-mem (vm adr val)
  (setf (aref (get vm 'mem) adr) val))

					; admet un entier comme adresse
(defun lire-mem (vm adr)
  (aref (get vm 'mem) adr))

					; ecriture et lecture d'un registre de la vm
(defun lire-reg (vm reg)
  (get vm reg))

(defun ecrire-reg (vm reg val)
  (setf (get vm reg) val))

					; utile pour le LOAD
(defun lire-emplacement (vm adr)
  (if (atom adr)
					; adressage direct
      (if (numberp adr)
					; avec un nombre donc une adresse dure ds la memoire
	  (lire-mem vm adr)
					; avec un registre
	(lire-reg vm adr))
					; ce n'est pas direct
    (if (numberp (car adr))
					; adressage indexé
	(if (atom (cadr adr))
					; on est en indexé simple (sans indirection)
	    (if (numberp (cadr adr))
					; on indexe un nombre
		(lire-mem vm (+ (car adr) (cadr adr)))
					; on a pas un nombre
	      (lire-mem vm (+ (car adr) (lire-reg vm (cadr adr)))))
					; on est en indexé avec un liste derriere (10 (???))
	  (if (eql (caadr adr) '*)
					; on est en indirect indexé
	      (if (numberp (cadadr adr))
					; on indirecte un entier donc une case memoire
		  (lire-mem vm (+ (car adr) (lire-mem vm (cadadr adr))))
					; on indirecte sans doute un registre
		(lire-mem vm (+ (car adr) (lire-mem vm (lire-reg vm (cadadr adr))))))
					; on indexe qqch qui n'est ni indirect ni direct
	    (error "~s : ce mode d'adressage n'est pas connu" adr)))
					; ce n'est pas indexé donc peut etre indirect
      (if (eql (car adr) '*)
					; oui c'est indirect mais est-ce une indirection de reg ou de case memoire
	  (if (numberp (cadr adr))
					; indirection de case memoire
	      (lire-mem vm (lire-mem vm (cadr adr)))
					; c'est une indirection de reg
	    (lire-mem vm (lire-mem vm (lire-reg vm (cadr adr)))))
					; ce n'est ni une indirection ni un index
	(error "~s : ce mode d'adressage n'est pas connu" adr)))))

					; utile pour le STORE, ecrit dans 'adr' la valeur val.
					; 'adr' peut etre un registre, une adresse, indexée, indirecte ou les deux...
(defun ecrire-emplacement (vm adr val)
  (if (atom adr)
					; adressage direct
      (if (numberp adr)
					; avec un nombre donc une adresse dure ds la memoire
	  (ecrire-mem vm adr val)
					; avec un registre
	(ecrire-reg vm adr val))
					; ce n'est pas direct
    (if (numberp (car adr))
					; adressage indexé
	(if (atom (cadr adr))
					; on est en indexé simple (sans indirection)
	    (if (numberp (cadr adr))
					; on indexe un nombre
		(ecrire-mem vm (+ (car adr) (cadr adr)) val)
					; on a pas un nombre : on indexe un registre
	      (ecrire-mem vm (+ (car adr) (lire-reg vm (cadr adr))) val))
					; on est en indexé avec un liste derriere (10 (???))
	  (if (eql (caadr adr) '*)
					; on est en indirect indexé
	      (if (numberp (cadadr adr))
					; on indirecte un entier donc une case memoire
		  (ecrire-mem vm (+ (car adr) (lire-mem vm (cadadr adr))) val)
					; on indirecte sans doute un registre
		(ecrire-mem vm (+ (car adr) (lire-mem vm (lire-reg vm (cadadr adr)))) val))
					; on indexe qqch qui n'est ni indirect ni direct
	    (error "~s : ce mode d'adressage n'est pas connu" adr)))
					; ce n'est pas indexé donc peut etre indirect
      (if (eql (car adr) '*)
					; oui c'est indirect mais est-ce une indirection de reg ou de case memoire ?
	  (if (numberp (cadr adr))
					; indirection de case memoire
	      (ecrire-mem vm (lire-mem vm (cadr adr)) val)
					; c'est une indirection de reg
	    (ecrire-mem vm (lire-mem vm (lire-reg vm (cadr adr))) val))
					; ce n'est ni une indirection ni un index
	(error "~s : ce mode d'adressage n'est pas connu" adr)))))



					; MOVE
					; TODO prendre en compte les valeurs immediates et les noms de reg differement
					; presque fait : reste a unquote
(defun vm-move (vm r0 r1)
  (print "je fais un move")
					; nombre : val immediate
  (if (numberp r1)
      (ecrire-reg vm r0 r1)
    (if (not (symbolp r1))
					; pas un symbole : val immediate chaine
	(ecrire-reg vm r0 r1)
					; registre
      (ecrire-reg vm r0 (lire-reg vm r1)))))

					; LOAD et STORE
(defun vm-load (vm r0 r1)
					; on ne sait pas si on va chercher dans un reg ou ds la memoire
  (ecrire-reg vm r0 (lire-emplacement vm r1)))

					; on ecri la valeur d'un registre (le param r1) dans un registre ou une case memoire
(defun vm-store (vm r0 r1)
  (ecrire-emplacement vm r0 (lire-reg vm r1)))



					; ADD SUB MULT DIV INCR DECR
(defun vm-add (vm r0 r1)
  (ecrire-reg vm r0 (+ (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-sub (vm r0 r1)
  (ecrire-reg vm r0 (- (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-mult (vm r0 r1)
  (ecrire-reg vm r0 (* (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-div (vm r0 r1)
  (ecrire-reg vm r0 (/ (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-incr (vm reg)
  (ecrire-reg vm reg (+ (lire-reg vm reg) 1)))

(defun vm-decr (vm reg)
  (ecrire-reg vm reg (- (lire-reg vm reg) 1)))

					; POP et PUSH
					; PUSH : on incremente le SP et on ecrit le contenu de 'reg' a l'adresse SP
(defun vm-push (vm reg)
  (ecrire-reg vm 'SP (+ (lire-reg vm 'SP) 1))
  (vm-store vm (lire-reg vm 'SP) reg))
					; POP : on met dans 'reg' la valeur qui est a l'adresse SP et on decremente SP
(defun vm-pop (vm reg)
  (vm-load vm reg (lire-reg vm 'SP))
  (ecrire-reg vm 'SP (- (lire-reg vm 'SP) 1)))

					; instruction CMP de la vm
(defun vm-cmp (vm r1 r2)
					; remise a zero des registres de comparaison
  (ecrire-reg vm 'DE 0)
  (ecrire-reg vm 'DG 0)
  (ecrire-reg vm 'DP 0)
  (if (< r1 r2)
      (ecrire-reg vm 'DP 1)
    (if (> r1 r2)
	(ecrire-reg 'DG 1)
      (ecrire-reg 'DE 1))))

					; on peut jmp uniquement dans le code
(defun adr-valide-p (vm adr)
  (and (> adr (lire-reg vm 'fincode)) (< adr (lire-reg vm 'debcode))))

					; renvoie l'adresse correspondante a une etiquette, nil si non trouvée
					;(defun get-adr-etiq (vm etiq)
					;  (assoc etiq (lire-reg vm 'tabetiq)))

					; instruction JMP
(defun vm-jmp (vm etiq)
					; si c'est une etiquette
  (if (not (numberp etiq))
					; TODO cela n'a pas de raison d'etre. le load ne laisse pas d'etiquette a un jmp
      (if (fboundp etiq)
	  (funcall etiq (lire-mem vm (+ (lire-reg vm 'FP) xx) (+ (lire-reg vm 'FP) xx)))
	(error "~s n'est pas une fonction définie dans clisp, ou alors vous avez oublié de la meta definie" etiq))
					; si c'est une adresse valide
    (if (adr-valide-p vm etiq)
	(ecrire-reg vm 'CO (+ etiq 1))
      (error "on ne peut faire de JMP vers ~s. Address out of bounds" etiq))))

					; Appel de sous routine aka appel de fonction
(defun vm-jsr (vm adr)
  (print "je suis dans le jsr")
  (if (numberp adr)
      (progn (vm-push vm (- (lire-reg vm 'CO) 1))
	     (vm-jmp vm adr))
    (if (fboundp adr)
	(progn (setq lparams ())
	       (loop for indice from (lire-mem vm (lire-reg vm 'FP)) downto 1
		     append (list (lire-mem vm (- (lire-reg vm 'FP) indice))) into lparams_loop
		     finally (setq lparams lparams_loop))
	       (print "une fonction externe est appellée avec les parametres")
	       (print lparams)
	       (if lparams
		   (apply adr lparams)
		 (funcall adr )))
      (error "~s n'est pas une fonction définie dans clisp, ou alors vous avez oublié de la meta definir" adr))))

					; differents choix possibles pour le RTN
					; soit on peut pop dans CO
					;(defun vm-rtn (vm)
					;  (vm-pop vm 'CO))
					; soit on peu pop dans des reg uniquement, ensuite on jmp au contenu du reg
(defun vm-rtn (vm)
  (vm-pop vm 'R2)
  (vm-jmp vm (lire-reg vm 'R2)))

					; instructions de saut conditionnel
(defun vm-jeq (vm adr)
  (if (and (eq (lire-reg vm 'DE) 1)
	   (eq (lire-reg vm 'DG) 0)
	   (eq (lire-reg vm 'DP) 0))
      (vm-jmp vm adr)
					; sinon rien
    ))
(defun vm-jpp (vm adr)
  (if (and (eq (lire-reg vm 'DE) 0)
	   (eq (lire-reg vm 'DG) 0)
	   (eq (lire-reg vm 'DP) 1))
      (vm-jmp vm adr)
					; sinon rien
    ))
(defun vm-jpg (vm adr)
  (if (and (eq (lire-reg vm 'DE) 0)
	   (eq (lire-reg vm 'DG) 1)
	   (eq (lire-reg vm 'DP) 0))
      (vm-jmp vm adr)
					; sinon rien
    ))
(defun vm-jne (vm adr)
  (if (or (eq (lire-reg vm 'DE) 0)
	  (eq (lire-reg vm 'DG) 1)
	  (eq (lire-reg vm 'DP) 1))
      (vm-jmp vm adr)
					; sinon rien
    ))
(defun vm-jpe (vm adr)
  (if (or (eq (lire-reg vm 'DE) 1)
	  (eq (lire-reg vm 'DG) 0)
	  (eq (lire-reg vm 'DP) 1))
      (vm-jmp vm adr)
					; sinon rien
    ))
(defun vm-jge (vm adr)
  (if (or (eq (lire-reg vm 'DE) 1)
	  (eq (lire-reg vm 'DG) 1)
	  (eq (lire-reg vm 'DP) 0))
      (vm-jmp vm adr)
					; sinon rien
    ))

					; HALT
(defun vm-halt (vm)
  (ecrire-reg vm 'RUN 0))

					; NOP
(defun vm-nop (vm)
  t)



(defun make-vm (nom taillemem env)
					; INIT VM
					; on crée une mémoire de 10 000 cases
					; (ecrire-reg 'mavm 'mem  (make-array '(10000) :initial-contents '((1) (2) (3)) ))
  (ecrire-reg nom 'mem  (make-array '(10000) ))

  (ecrire-reg nom 'r0 1)
  (ecrire-reg nom 'r1 2)
  (ecrire-reg nom 'r2 3)

  (ecrire-reg nom 'DE 0)
  (ecrire-reg nom 'DG 0)
  (ecrire-reg nom 'DP 0)

  (ecrire-reg nom 'SP 0)
  (ecrire-reg nom 'BP 1)
  (ecrire-reg nom 'FP 1)

  (ecrire-reg nom 'RUN 0)

  (ecrire-reg nom 'CO 500)

					; partie utile pour le loader
					; contient l'adresses correspondantes aux étiquettes : (get hash 'une-etiquette etiq-loc) =>  (123)
  (ecrire-reg nom 'etiq-loc (make-hash-table :size 50 :test 'eq))
					; etiquettes locales non resolues sous la forme 'etiq => (23 45 98) : les adresse ou on saute a cette etiq
  (ecrire-reg nom 'etiq-loc-nr (make-hash-table :size 50 :test 'eq))
					; resolution des etiquettes globales : etiq => (666)
  (ecrire-reg nom 'etiq-glob (make-hash-table :size 50 :test 'eq))
					; pour chaque etiq glob non resolue : la liste des adresses ou on y fait reference
  (ecrire-reg nom 'etiq-glob-nr (make-hash-table :size 50 :test 'eq))

					; adresses de debut et fin de code chargé dans la vm
  (ecrire-reg nom 'debcode (- taillemem 1))
					; premiere case libre pour du code
  (ecrire-reg nom 'fincode (- taillemem 1))

  )

(defun command (vm com)
  (eql (car (lire-mem vm (lire-reg vm 'CO))) com))


(defun run-vm (vm start)

  (ecrire-reg vm 'RUN 1)
  (ecrire-reg vm 'CO start)

					; TODO analyse par cas améliorée
  (loop while (eql (lire-reg vm 'RUN) 1)
	do (if (command vm 'ADD)
	       (vm-add vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
	     (if (command vm 'HALT)
		 (vm-halt vm)
	       (if (command vm 'JMP)
		   (vm-jmp vm (cadr (lire-mem vm (lire-reg vm 'CO))))
		 (if (command vm 'JSR)
		     (vm-jsr vm (cadr (lire-mem vm (lire-reg vm 'CO))))
		   (if (command vm 'SUB)
		       (vm-sub vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
		     (if (command vm 'MULT)
			 (vm-mult vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
		       (if (command vm 'DIV)
			   (vm-div vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			 (if (command vm 'LOAD)
			     (vm-load vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			   (if (command vm 'STORE)
			       (vm-store vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			     (if (command vm 'MOVE)
				 (vm-move vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			       (if (command vm 'INCR)
				   (vm-incr vm (cadr (lire-mem vm (lire-reg vm 'CO))))
				 (if (command vm 'DECR)
				     (vm-decr vm (cadr (lire-mem vm (lire-reg vm 'CO))))
				   (if (command vm 'PUSH)
				       (vm-push vm (cadr (lire-mem vm (lire-reg vm 'CO))))
				     (if (command vm 'POP)
					 (vm-pop vm (cadr (lire-mem vm (lire-reg vm 'CO))))))))))))))))))

					; on decremente le CO car le code est descendant
	do (vm-decr vm 'CO)
					; on est content
	do (print "lalala")))

					; peudo load temporaire : ne fait pas la resolution d'etiquettes
(defun vm-load-ulfa (vm adr file)
  (setf (get 'mavar 'adr) adr)
  (with-open-file (stream file
			  :direction :input
			  :if-does-not-exist :error)
		  (loop for bloc = (read stream nil 'EOF)
			until (eql bloc 'EOF)
			do (ecrire-mem vm (get 'mavar 'adr) bloc)
			do (setf (get 'mavar 'adr) (- (get 'mavar 'adr) 1))
			do (print '--)
			)))

					; TODO effacer les non resolues dans le glob-nr puisqu'on les as resolues!
					; resolvation des globales
(defun resoudre-globales-nr (vm adr etiq)
  (loop for adr-a-res in (gethash etiq (lire-reg vm 'etiq-glob-nr))
	do (setf (cadr (aref (get vm 'mem) adr-a-res)) adr)
	)
  (setf (gethash etiq (lire-reg vm 'etiq-glob-nr)) nil))

					; resolvation des locales
(defun resoudre-locales-nr (vm adr etiq)
					;(print "je suis dans la resolution arriere")
					;(print  (gethash etiq (lire-reg vm 'etiq-loc-nr)))
  (loop for adr-a-res in (gethash etiq (lire-reg vm 'etiq-loc-nr))
					;do (print "je resoud a ladresse")
					;do (print adr-a-res)
	do (setf (cadr (aref (get vm 'mem) adr-a-res)) adr)
	)
  (setf (gethash etiq (lire-reg vm 'etiq-loc-nr)) nil)
  )

					; est ce un saut?
(defun jump-p (instr)
  (or (eql instr 'JMP)
      (eql instr 'JSR)
      (eql instr 'JEQ)
      (eql instr 'JNE)
      (eql instr 'JPG)
      (eql instr 'JPP)
      (eql instr 'JPE)
      (eql instr 'JGE)))


					; loader, charge du code a partir de 'fincode
					; attention on utilise un symbole global comme variable pour se souvenir ou on ecrit. non parallel
					;
					; on doit faire les choses par bloc de code chargé : un bloc = defun...rtn
					; pour vider le tableau detiquettes locales
					;
(defun vm-loader (vm file)
  (setf (get 'adr-ecr 'adr) (lire-reg vm 'fincode))
  (with-open-file (stream file
			  :direction :input
			  :if-does-not-exist :error)
					; on boucle sur les defun tant qu'on ne trouve pas un EOF
		  (loop for instr = (read stream nil 'EOF)
			until (eql instr 'EOF)
					; si le premier instr est bien un defun
			do (if (eql (car instr) 'DEFUN)
					; premiere chose a faire : definir l'etiquette
			       (progn 
					; on la definit
				 (setf (gethash (cadr instr) (lire-reg vm 'etiq-glob)) (get 'adr-ecr 'adr))
					; on resoud les endroits ou on y a fait reference
				 (resoudre-globales-nr vm (get 'adr-ecr 'adr) (cadr instr))
					; on boucle sur les instructions tant que l'on obtient pas un RTN
				 (loop for bloc-instr = (read stream nil 'EOF)
				       until (eql (car bloc-instr) 'RTN)

					; gestion de l'instruction labels
					; ils ne sont pas ecris dans la memoire!!
				       do (if (eql (car bloc-instr) 'LABELS)
					      (progn
						(setf (gethash (cadr bloc-instr) (lire-reg vm 'etiq-loc)) (get 'adr-ecr 'adr))
						(print "je doi resoudre le labels")
						(print (cadr bloc-instr))
						(resoudre-locales-nr vm (get 'adr-ecr 'adr) (cadr bloc-instr)))

					; sinon : si ce n'est pas un labels : on traite les autres cas et on ecrit l'instruction
					    (progn 
					; gestion des sauts, on doit resoudre les adresses
					; il faut différencier les sauts vers des locales ou globales
					;(if (jump-p (car bloc-instr))
					;le cas d'un saut vers une globale : appel de fonction, MAYBE TEMPORAIRE
					      (if (eql (car bloc-instr) 'JSR)
					; si la globale est definie
						  (if (gethash (cadr bloc-instr) (lire-reg vm 'etiq-glob))
					; on resoud l'etiquette globale
						      (setf (cadr bloc-instr)
							    (gethash (cadr bloc-instr) (lire-reg vm 'etiq-glob)))
					; sinon on ajoute l'adresse ou on va ecrire dans les NR
						    (setf (gethash (cadr bloc-instr) (lire-reg vm 'etiq-glob-nr))
							  (cons (get 'adr-ecr 'adr)
								(gethash (cadr bloc-instr) (lire-reg vm 'etiq-glob-nr)))))
					; ce n'est pas un JSR donc pas une globale
					; est-ce tout de meme un saut?
						(if (jump-p (car bloc-instr))
					; si la locale est definie
						    (if (gethash (cadr bloc-instr) (lire-reg vm 'etiq-loc))
					; on resoud l'etiquette locale
							(setf (cadr bloc-instr)
							      (gethash (cadr bloc-instr) (lire-reg vm 'etiq-loc)))
					; sinon on ajoute l'adresse ou on va ecrire dans les locales NR
						      (setf (gethash (cadr bloc-instr) (lire-reg vm 'etiq-loc-nr))
							    (cons (get 'adr-ecr 'adr)
								  (gethash (cadr bloc-instr) (lire-reg vm 'etiq-loc-nr))))))
						)
					; ensuite quelle que soit l'instruction : on l'ecrit dans la memoire
					      (ecrire-mem vm (get 'adr-ecr 'adr) bloc-instr)
					      (setf (get 'adr-ecr 'adr) (- (get 'adr-ecr 'adr) 1))
					      (print '--)))
				       )
					; apres le traitement du bloc 'defun...rtn', on efface les etiquettes locales
					; cela verifie qu'elles sont toutes bien résolues
				 (vider-etiq-locales vm))
					; si ce n'est pas un defun
			     (error "~s est une mauvaise instruction de debut de bloc" instr)))
					; on met a jour le registre fincode
		  (ecrire-reg vm 'fincode (get 'adr-ecr 'adr))))

					; verifie que toutes les etiquettes locales sont résolues
					; si oui : on efface le contenu de etiq-loc et etiq-loc-nr
					;
					; (loop for key being the hash-keys of (lire-reg 'vvvm 'etiq-loc-nr)
					; append (list key) into lala finally (return lala))
(defun vider-etiq-locales (vm)
  (setq res nil)
					; je boucle sur les cles de etiq-loc-nr qui ne pointent pas vers vide
  (loop for key being the hash-keys of (lire-reg vm 'etiq-loc-nr) 
	when (not (eql (gethash key (lire-reg vm 'etiq-loc-nr)) nil))
					; je cree une liste d'etiquettes locales non resolues
	append (list key) into lala 
					; a la fin je met cette liste dans le symbole res
	finally (setq res lala))
  (if (eql res nil)
      (progn (print "tout est ok je peux suppr les etiq-loc")
	     (ecrire-reg vm 'etiq-loc (make-hash-table :size 50 :test 'eq))
	     (ecrire-reg vm 'etiq-loc-nr (make-hash-table :size 50 :test 'eq)))
    (error "les etiq locales : ~s ne sont pas resolues" res)))

					; ecrit le contenu de la memoire de deb à fin
(defun dump-mem (vm deb fin)
					; variable de parcours de la memoire
  (setf (get 'adr-dump 'adr) deb)
  (loop for case-mem = (lire-mem vm (get 'adr-dump 'adr))
	until (eql (get 'adr-dump 'adr) (- fin 1))
	do (print (get 'adr-dump 'adr))
	do (print case-mem)
	do (setf (get 'adr-dump 'adr) (- (get 'adr-dump 'adr) 1))))


					; ulfa tests de la super vm ------------------------------------------------

					;(make-vm 'vvvm 1000 ())
					;(vm-load-ulfa 'vvvm 1000 "ass.lisp")
					;(print (lire-reg 'vvvm 'r0))
					;(run-vm 'vvvm 1000)
					;(print (lire-reg 'vvvm 'r0))
					;(print "j'ai lu les raiegistres")

					; tests du super load --------------------------------

(make-vm 'vvvm 1000 ())
(vm-loader 'vvvm "ass.lisp")
(print (lire-reg 'vvvm 'r0))
(run-vm 'vvvm 1000)
(print (lire-reg 'vvvm 'r0))
(print "j'ai lu les raiegistres")
